home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / strategy.scm < prev    next >
Encoding:
Text File  |  1992-02-17  |  3.5 KB  |  109 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File strategy.scm / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Compute strategy for compiling a LETREC
  5.  
  6. (define (get-letrec-strategy node)
  7.   (or (letrec-strategy node)
  8.       (let ((strategy
  9.          (let ((vars (letrec-vars node))
  10.            (vals (letrec-vals node)))
  11.            (cond ((or (null? vars)
  12.               (not (function-bindable? vars vals)))
  13.               'general)
  14.              ((or (some variable-value-refs? vars)
  15.               (some n-ary? vals)
  16.               (exists-losing-call? node))
  17.               'labels)
  18.              (else 'prog)))))
  19.     (set-letrec-strategy! node strategy)
  20.     strategy)))
  21.  
  22. ; The following procedure does a tail recursion analysis to find calls
  23. ; to the labels functions that are in non-tail-recursive positions.
  24.  
  25. (define (exists-losing-call? node)
  26.   (let ((vars (letrec-vars node)))
  27.     (or (contains-loser? (letrec-body node) vars 'win)
  28.     (some (lambda (proc)
  29.         (call-will-lose? proc vars 'win))
  30.           (letrec-vals node)))))
  31.  
  32. (define (contains-loser? node vars k)
  33.   (case (node-type node)
  34.     ((local-variable program-variable constant) #f)
  35.     ((letrec)
  36.      (or (contains-loser? (letrec-body node) vars k)
  37.      (if (eq? (get-letrec-strategy node) 'prog)
  38.          (some (lambda (proc)
  39.              (call-will-lose? proc vars k))
  40.            (letrec-vals node))
  41.          (list-contains-loser? (letrec-vals node) vars 'lose))))
  42.     ((if)
  43.      (or (contains-loser? (if-test node) vars 'lose)
  44.      (contains-loser? (if-con node) vars k)
  45.      (contains-loser? (if-alt node) vars k)))
  46.     ((begin)
  47.      (or (contains-loser? (begin-first node) vars 'lose)
  48.      (contains-loser? (begin-second node) vars k)))
  49.     ((set!)
  50.      (contains-loser? (set!-rhs node) vars 'lose))
  51.     ((lambda)
  52.      (contains-loser? (lambda-body node) vars 'lose))
  53.     ((call)
  54.      (let ((proc (call-proc node)))
  55.        (cond ((lambda? proc)
  56.           ;;+++ Could deal with (let ((p (lambda ...))) ... (p ...))
  57.           ;; here, but punt for now.
  58.           (or (call-will-lose? proc vars k)
  59.           (list-contains-loser? (call-args node) vars 'lose)))
  60.          ((program-variable? proc)
  61.           (let ((n (number-of-non-continuation-args proc)))
  62.         (if n
  63.             (let loop ((a (call-args node)) (i 0))
  64.               (if (= i n)
  65.               (some (lambda (arg)
  66.                   (call-will-lose? arg vars k))
  67.                 a)
  68.               (or (contains-loser? (car a) vars 'lose)
  69.                   (loop (cdr a) (+ i 1)))))
  70.             (list-contains-loser? (call-args node) vars 'lose))))
  71.          (else
  72.           (or (if (memq proc vars)
  73.               (eq? k 'lose)
  74.               (contains-loser? proc vars 'lose))
  75.           (list-contains-loser? (call-args node) vars 'lose))))))
  76.     (else (error "unknown node type" node))))
  77.  
  78. (define (list-contains-loser? node-list vars k)
  79.   (some (lambda (node)
  80.       (contains-loser? node vars k))
  81.     node-list))
  82.  
  83. ; PROC-NODE will be evaluated and then immediately invoked.
  84.  
  85. (define (call-will-lose? proc-node vars k)
  86.   (if (lambda? proc-node)
  87.       (contains-loser? (lambda-body proc-node) vars k)
  88.       (contains-loser? proc-node vars 'lose)))
  89.  
  90. (define (number-of-non-continuation-args var)
  91.   ;; Kind of slow -- should speed this up somehow?  This information
  92.   ;; ought to be in the integrations-table, at least.
  93.   (cond ((or (eq? var (built-in 'and-aux))
  94.          (eq? var (built-in 'or-aux)))
  95.      1)
  96.     ((eq? var (built-in '=>-aux)) 2)
  97.     ((eq? var (built-in 'case-aux)) 1)
  98.     (else #f)))
  99.  
  100. ; True if it will be possible to bind the variables using FLET or LABELS.
  101.  
  102. (define (function-bindable? vars vals)
  103.   (and (not (null? vars))
  104.        (every (lambda (var)
  105.         ;; Maybe require that there be no non-function refs?
  106.         (not (variable-assigned? var)))
  107.           vars)
  108.        (every lambda? vals)))
  109.